;; Spp implement with newLISP

;;===========================================================
;; Initial global symbol table

(new Tree   'Main)
(Main "Main" Main)
(set '$NS    Main)
(set '$CALL  Main)
(set '$BLOCK Main)
(set '@NS    (cons $NS))
(set '@CALL  (cons $CALL)) 
(set '@BLOCK (cons $BLOCK))

;;===========================================================
;; Global Variable

(set '$LANG      "Spp")
(set '$SPP-JSON  "rule/Spp.json")
(set '$SPP-LSP   "rule/Spp.rule")
(set '$SPP-RULE  "rule/Spp.spp")
(set '$TC        0) 

;; ==========================================================
;; global variable for match grammar/rule

(set '$STR    "")
(set '$POS    0)
(set '$MAXPOS 0)
(set '$LEN    0)
(set '$DEPTH  0)
(set '@LOG    '())

;;===========================================================
;; newlisp function name reflection for easy read and write

(constant 'return  throw)
(constant 'str     string)
(constant 'len     length)
(constant 'range   sequence)
(constant 'say     println)
(constant 'is-file file?)
(constant 'is-nil  nil?)
(constant 'is-int  number?)
(constant 'is-str  string?)
(constant 'is-sym  symbol?)
(constant 'is-ns   context?)
(constant 'is-list list?)
(constant 'is-obj  array?)

;; ==========================================================
;; constant for replace
;; ==========================================================

(constant '$TO (cons "to" "->"))
(constant '$DOT (cons "dot" "."))
(constant '$BRANCH (cons "branch" "|"))

;;===========================================================
;; common tools
;;===========================================================

(define (uid) (new Tree (sym (str "Hash-" (++ 1)))))

(define (to-obj) (array (len (args)) (args)))

(define (error) (apply say (cons "error: " (args))) (exit))

(define (load-json @x)
  (cond
    ((is-file @x) (json-parse (read-file @x)))
    (true (error @x " not exists!"))))

(define (is-true @x) (= true @x))
(define (not-nil @x) (not (is-nil @x)))
(define (is-ref @x) (and (is-obj @x) (= "ref" (@x 0))))
(define (is-func @x) (and (is-obj @x) (= "func" (@x 0))))
(define (is-array @x) (and (is-obj @x) (= "array" (@x 0))))
(define (is-rule @x) (and (is-obj @x) (= "rule" (@x 0))))

(define (is-op @sym)
  (and (is-sym @sym) (find (term @sym) 
      (parse {~~ >> << == =~ != = > >= < <= + - in}))))

(define (get-token-rule @name, @rule)
  (set '@rule ($NS @name))
  (cond
    ((is-rule @rule) (last @rule))
    (true (error "Could not find rule: "@name))))

(define (delete-context @sym, @name)
  (set '@name (sym (term @sym)))
  (delete @name) (delete @name))

(define (in-ns @name, @namespace)
  (cond
    ((is-str @name)
      (set '@namespace (Main @name))
      (cond
        ((is-ns @namespace) (in-context @namespace))
        (true (error @name " is not grammar name!"))))
    (true (throw-error "(in-ns str) accept string! " @name))))

(define (out-ns @name, @namespace)
  (cond
    ((is-str @name)
      (set '@namespace (Main @name))
      (cond
        ((is-ns @namespace) (out-context @namespace))
        (true (error @name" != current grammar: " $NS))))
    (true (error "(end ns) only accept string! " @name))))

(define (in-context @name)
  (push @name @NS) (set '$NS @name))

(define (out-context @name)
  (cond
    ((= @name $NS) (pop @NS) (set '$NS (first @NS)))
    (true (error @name " != current context: "$NS))))

(define (in-func @name)
  (push @name @NS) (set '$NS @name)
  (push @name @CALL) (set '$CALL @name))

(define (out-func @name)
  (cond
    ((= @name $CALL)
      (delete-context @name)
      (pop @NS) (set '$NS (first @NS))
      (pop @CALL) (set '$CALL (first @CALL)))
    (true (error @name " != current Call: "$CALL))))

(define (in-block @name)
  (push @name @NS) (set '$NS @name)
  (push @name @BLOCK) (set '$BLOCK @name))

(define (out-block @name)
  (cond
    ((= @name $BLOCK)
      (delete-context @name)
      (pop @NS) (set '$NS (first @NS))
      (pop @BLOCK) (set '$BLOCK (first @BLOCK)))
    (true (error @name " != current block: "$BLOCK))))

(define (to-json @atom)
  (cond
    ((is-str @atom)  (str-to-str @atom))
    ((list? @atom)
      (str "[" (join (map to-json @atom) ",") "]"))
    (true (error " unknown atom to json: " @atom))))

(define (substr @str @from @to)
  (cond
    ((< @from 0) (slice @str 0 @to))
    (true (slice @str (+ @from 1) (- @to @from 1)))))

(define (get-tip-str @from @pos @to)
  (string (dup " " (- @pos @from))
    "^" (dup " " (- @to @pos 1))))

;;===========================================================
;; Optimizer Match Data
;;===========================================================
(define (opt-exprs @exprs)
  (set '@exprs (map opt-atom @exprs))
  (cond
    ((= 1 (len @exprs)) (first @exprs))
    (true (list 'exprs @exprs))))

(define (opt-match @match)
  (cond
    ((is-true @match) true)
    ((is-str  @match) @match)
    ((is-name-match @match) (opt-atom @match))
    (true (opt-exprs @match))))

(define (opt-atom @atom, @type @value)
  (map set '(@type @value) @atom)
  (case @type
    ("int"     (int @value))
    ("sym"     (opt-sym @value))
    ("char"    (opt-char @value))
    ("sstr"    @value)
    ("keyword" @value)
    ("to"      @atom)
    ("dot"     @atom)
    ("str"     (opt-str @value))
    ("@list"   (opt-list @value))
    ("@array"  (opt-array @value))
    ("@rule"   (opt-rule @value))
    (true (error "unknown opt atom type "@type))))

(define (opt-sym @str)
  (case @str
    ("nil" nil)
    ("true" true)
    (true (sym @str))))

(define (opt-char @value)
  (case (0 2 @value)
    ("\\a" "\x07")
    ("\\e" "\x1B")
    ("\\f" "\x0C")
    ("\\n" "\n")
    ("\\r" "\r")
    ("\\t" "\t")
    ("\\x" (char (int (str "0" (rest @value))))) 
    (true (error "error string char" @value))))

(define (opt-str @nodes, @strs @type @value)
  (cond
    ((= @nodes {""}) @nodes)
    (true 
      (set '@strs '())
      (dolist (@node @nodes)
        (map set '(@type @value) @node)
        (case @type
          ("char"  (push (opt-char @value) @strs -1))
          ("schar" (push (last @value) @strs -1))
          ("sstr"  (push @value @strs -1))
          (true (error "unknown string node: " @type))))
      (join @strs))))

(define (opt-array @array)
  (cond
    ((= "[]" @array) (to-obj "array" '()))
    (true (to-obj "array" (map opt-atom @array)))))

(define (opt-list @list)
  (cond
    ((= "()" @list) '())
    (true
      (set '@list (map opt-atom @list))
      ;; (return 1 if (x > 1))
      ;; => (if (x > 1) (return 1))
      (set '@list (opt-if @list))
      ;; (x > 1) => (> x 1)
      (set '@list (opt-op @list))
      ;; package . sym
      (when (find $DOT @list)
        (set '@list (opt-dot @list)))
      ;; (a b -> x) => (x a b)
      (when (find $TO @list)
        (set '@list (opt-to @list)))
      @list)))

(define (opt-if @list)
  (cond
    ((> (len @list) 2)
      (cond
        ((= 'if (@list -2))
          (set '@list (append (-2 @list) (cons (0 -2 @list)))))
        (true @list)))
    (true @list)))

(define (opt-op @list)
  (cond
    ((= 3 (len @list))
      (cond
        ((is-op (nth 1 @list))
          (swap (@list 1) (@list 0)) @list)
        (true @list)))
    (true @list)))

(define (opt-dot @list, @flag @cache @atoms)
  (set '@flag 0 '@atoms '())
  (dolist (@atom @list)
    (cond
      ((= @flag 0)
        (cond
          ((= @atom $DOT) true)
          (true (set '@cache @atom '@flag 1))))
      ((= @flag 1)
        (cond
          ((= @atom $DOT) (set '@flag 2))
          (true (push @cache @atoms -1)
            (set '@cache @atom))))
      (true
        (cond
          ((= @atom $DOT) true)
          (true
            (set '@flag 1)
            (set '@cache (to-obj "ref" (list @cache @atom))))))))
  (if (> @flag 0) (push @cache @atoms -1) @atoms))

(define (opt-to @atoms)
  (set '@atoms (split-to @atoms))
  ;; (say @atoms)
  (combin-to @atoms))

(define (split-to @atoms, @flag @cache @exprs)
  (set '@flag 0 '@exprs '())
  (dolist (@atom @atoms)
    (cond
      ((= 0 @flag)
        (cond
          ((= @atom $TO) true)
          ((is-list @atom)
            (set '@flag 1)
            (push @atom @exprs -1))
          (true (set '@flag 2 '@cache @atom))))
      ((= 1 @flag)
        (cond
          ((= @atom $TO)
            (set '@flag 0)
            (push $TO @exprs -1))
          ((is-list @atom)
            (push @atom @exprs -1))
          (true (set '@flag 2 '@cache @atom))))
      ((= 2 @flag)
        (cond
          ((= @atom $TO)
            (push @cache @exprs -1)
            (push $TO @exprs -1)
            (set '@flag 0 '@cache nil))
          (true
            (inc @flag)
            (set '@cache (list @cache @atom)))))
      (true
        (cond
          ((= @atom $TO)
            (push @cache @exprs -1)
            (push $TO @exprs -1)
            (set '@flag 0 '@cache nil))
          (true (push @atom @cache -1))))))
  (if (true? @cache) (push @cache @exprs -1))
  (cond
    ((= 1 (length @exprs)) (first @exprs))
    (true @exprs)))

(define (combin-to @exprs, @flag @cache @atoms)
  (set '@flag 0 '@atoms '())
  (dolist (@atom @exprs)
    (cond
      ((= @flag 0)
        (cond
          ((= @atom $TO) true)
          (true (set '@cache @atom '@flag 1))))
      ((= @flag 1)
        (cond
          ((= @atom $TO) (set '@flag 2))
          (true
            (push @cache @atoms -1)
            (set '@cache @atom))))
      (true
        (cond
          ((= @atom $TO) true)
          (true (set '@flag 1)
            (set '@cache (concat-to @cache @atom)))))))
  (if (> @flag 0) (push @cache @atoms -1) @atoms)
  (cond
    ((= 1 (length @atoms)) (first @atoms))
    (true @atoms)))

(define (concat-to @cache @atom)
  (cond
    ((and (is-list @cache) (= 'to (first @cache)))
      (push @atom @cache -1))
    (true (list 'to @cache @atom))))

(define (opt-rule @atoms, @rules @regex-rule)
  ;; (say "match -> " @atoms)
  (set '@rules (opt-rules @atoms))
  ;; (say "opt->" @rules)
  (set '@regex-rule (regex-rule @rules))
  ;; (say "regex->" @regex-rule)
  (to-obj "rule" @regex-rule))

;;===========================================================
;; Optimizer token Data directly to regex
;;===========================================================

(define (opt-token @atom, @type @value)
  (map set '(@type @value) @atom)
  (case @type
    ("@chclass" (list "regex" (opt-chclass @value)))
    ("char"     (list "regex" @value))
    ("escape"   (list "regex" @value))
    ("assert"   (list "regex" @value))
    ("any"      (list "regex" @value))
    ("name"     (list "regex" @value))
    ("rsstr"    (list "regex" (regex-str @value)))
    ("cclass"   (list "regex" (opt-out-cclass @value)))
    ("@group"   (opt-group @value))
    ("rstr"     (opt-rstr @value))
    ("@action"  (opt-action @value))
    ("rtoken"   @atom)
    ("gtoken"   @atom)
    ("ctoken"   @atom)
    ("ntoken"   @atom)
    (true (error "unknown token to opt: "@atom))))

(define (opt-rstr @nodes, @strs @type @value)
  (set '@strs '())
  (dolist (@node @nodes)
    (map set '(@type @value) @node)
    (case @type
      ("rsstr"  (push (regex-str @value) @strs -1))
      ("char"   (push @value @strs -1))
      ("rcchar" (push @value @strs -1))
      (true (error "unknown string node: "@type))))
  (list "regex" (str "(?:" (join @strs) ")")))

(define (regex-str @str)
  (replace {([()[\]{}|.+*?^$#])} @str (str {\} $1) 0))

(define (opt-out-cclass @value)
  (set '@value (opt-cclass @value))
  (case (first @value)
    ("["  (str "[" @value "]"))
    ("\\" @value)
    (true (error "unknown cclass: "@value))))

(define (opt-cclass @value)
  (case (last @value)
    ("b" {[:blank:]})
    ("B" {[:^blank:]})
    ("l" {[:lower:]})
    ("L" {[:^lower:]})
    ("u" {[:upper:]})
    ("U" {[:^upper:]})
    ("x" {[:xdigit:]})
    ("X" {[:^xdigit:]})
    (true @value)))

(define (opt-action @exprs)
  (list "action" (opt-match @exprs)))

(define (opt-rules @atoms, @rules)
  (cond
    ((find $BRANCH @atoms)
      (opt-branch (concat-branch @atoms)))
    (true
      (set '@rules (concat-rept-look @atoms))
      (if (= (len @rules) 1)
        (first @rules)
        (list "rules" @rules)))))

(define (opt-group @atoms, @rules)
  (cond
    ((find $BRANCH @atoms)
      (set '@rules (opt-branch (concat-branch @atoms)))
      (list "group" (cons @rules)))
    (true
      (list "group" (concat-rept-look @atoms)))))

(define (concat-branch @atoms, @flag @branch @branches)
  (set '@flag 0 '@branches '() '@branch '())
  (dolist (@atom @atoms)
    (cond
      ((= @atom $BRANCH)
        (when (= @flag 1)
          (push @branch @branches -1)
          (set '@flag 0 '@branch '())))
      (true
        (set '@flag 1)
        (push @atom @branch -1))))
  (if (= @flag 1) (push @branch @branches -1) @branches))

(define (opt-branch @branches, @atoms @atom)
  (set '@atoms '())
  (dolist (@branch @branches)
    (set '@atom (concat-rept-look @branch))
    (if (= (len @atom) 1)
      (push (@atom 0) @atoms -1)
      (push (list "rules" @atom) @atoms -1)))
  (list "branch" @atoms))

(define (concat-rept-look @atoms, @index @rules @look @rept)
  (set '@index 0 '@rules '())
  (if (= (first (last @atoms)) "look")
    (error "look should follow some atom"))
  (while (< @index (len @atoms))
    (set '@look (next-is-look @atoms @index))
    (set '@rept (next-is-rept @atoms @index))
    (cond
      ((true? @look) (++ @index 3) (push @look @rules -1))
      ((true? @rept) (++ @index 2) (push @rept @rules -1))
      (true
        (push (opt-token (@atoms @index)) @rules -1)
        (++ @index))))
  @rules)

(define (next-is-rept @atoms @index, @rept @token)
  (when (< @index (- (len @atoms) 1))
    (set '@rept (@atoms (+ 1 @index)))
    (when (= "rept" (@rept 0))
      (set '@token (@atoms @index))
      (list "rept"
        (list (opt-token @token)
          (opt-rept (@rept 1)))))))

(define (next-is-look @atoms @index, @token @rept @look)
  (when (< @index (- (len @atoms) 1))
    (set '@rept (@atoms (+ 1 @index)))
    (when (= "look" (@rept 0))
      (set '@token (@atoms @index))
      (set '@look (@atoms (+ 2 @index)))
      (list "look"
        (list (opt-token @token)
          (opt-look-rept (@rept 1))
          (opt-token @look))))))

(define (opt-rept @str)
  (case @str
    ("?" (list 0 1  @str))
    ("*" (list 0 -1 @str))
    ("+" (list 1 -1 @str))
    (true (error "Unknown rept str: "@str))))

(define (opt-look-rept @x) (opt-rept (last (first @x))))

(define (opt-chclass @nodes, @opt-nodes @type @value)
  (set '@opt-nodes '())
  (dolist (@node @nodes)
    (map set '(@type @value) @node)
    (case @type
      ("cclass" (push (opt-cclass @value) @opt-nodes -1))
      (true     (push @value @opt-nodes -1))))
  (str "[" (join @opt-nodes) "]"))

;; ===========================================
;; regex rule
;; ===========================================

(define (regex-rule @rule, @type @value)
  (map set '(@type @value) @rule)
  (case @type
    ("rept"   (regex-rept @value))
    ("look"   (regex-look @value))
    ("branch" (regex-branch @value))
    ("group"  (regex-group @value))
    ("rules"  (regex-rules @value))
    (true     @rule)))

(define (regex-rept @rules)
  (local (@rule @rept @rept-str @regex-str)
    (map set '(@rule @rept) @rules)
    (set '@rule (regex-rule @rule))
    (cond
      ((is-regex @rule)
        (set '@rept-str (last @rept))
        (set '@regex-str (str (last @rule) @rept-str))
        (list "regex" @regex-str))
      (true (list "rept" (list @rule @rept))))))

(define (regex-look @rules)
  (local (@rule @rept @look @rept-str @regex-str)
    (map set '(@rule @rept @look) @rules)
    (set '@rule (regex-rule @rule) '@look (regex-rule @look))
    (cond
      ((and (is-regex @rule) (is-regex @look))
        (set '@rept-str (str (last @rept) "?"))
        (set '@regex-str (str (@rule 1) @rept-str (@look 1)))
        (list "regex" @regex-str))
      (true (list "look" (list @rule @rept @look))))))

(define (regex-branch @rules)
  (set '@rules (map regex-rule @rules))
  (if (for-all is-regex @rules)
    (list "regex" (join (map last @rules) "|"))
    (list "branch" @rules)))

(define (regex-group @rules, @regex-str)
  (set '@rules (map regex-rule @rules))
  (set '@rules (combin-regex @rules))
  (cond
    ((and (= (len @rules) 1) (is-regex (first @rules)))
      (set '@regex-str (str "(" (last (@rules 0)) ")"))
      (list "regex" @regex-str))
    (true (list "group" @rules))))

(define (regex-rules @rules)
  (set '@rules (map regex-rule @rules))
  (set '@rules (combin-regex @rules))
  (cond
    ((and (= (length @rules) 1) (is-regex (first @rules)))
      (list "regex" (last (first @rules))))
    (true (list "rules" @rules))))

(define (combin-regex @rules, @flag @atoms @cache)
  (set '@atoms '() '@flag 0)
  (dolist (@rule @rules)
    (cond
      ((= @flag 0)
        (cond
          ((is-regex @rule) (set '@cache @rule '@flag 1))
          (true (push @rule @atoms -1))))
      (true
        (cond
          ((is-regex @rule)
            (set '@cache (concat-regex @cache @rule)))
          (true
            (push @cache @atoms -1)
            (push @rule @atoms -1)
            (set '@cache @rule '@flag 0))))))
  (if (= @flag 1) (push @cache @atoms -1) @atoms))

(define (is-regex @rule) (= "regex" (first @rule)))

(define (concat-regex)
  (list "regex" (apply str (map last (args)))))

;;===========================================================
;; match rule
;;===========================================================

(define (new-match @str)
  (set '$STR (trim @str))
  (set '$POS 0)
  (set '$LEN (len $STR))
  (set '$MAXPOS 0)
  (set '@LOG '()))

(define (is-name-match @x) (is-str (first @x)))

(define (match-grammar @grammar @str, @rule @match)
  (in-ns @grammar)
  (new-match @str)
  (set '@rule (get-token-rule "Top"))
  (set '@match (match-rule @rule))
  (out-ns @grammar)
  @match)

(define (match-rule @rule, @type @value)
  (map set '(@type @value) @rule)
  (case @type
    ("regex"  (match-regex   @value))
    ("rules"  (match-rules   @value))
    ("group"  (match-rules   @value))
    ("branch" (match-branch  @value))
    ("look"   (match-look    @value))
    ("rept"   (match-rept    @value))
    ("action" (match-action  @value))
    ("gtoken" (match-gtoken  @value))
    (true     (match-token   @rule))))

(define (match-regex @regex, @gather)
  ;; 22 = 2 + 4 + 16 (ms + anchor $POS + UTF8)
  (set '@gather (regex @regex $STR 22 $POS))
  (cond
    ((is-nil @gather) nil)
    (true
      (++ $POS (last @gather))
      (first @gather))))

(define (match-rules @x) (catch (_match-rules @x)))
(define (_match-rules @rules, @gather @match)
  (set '@gather true)
  (dolist (@rule @rules)
    (set '@match (match-rule @rule))
    (if (is-nil @match) (return nil))
    (set '@gather (gather-match @gather @match)))
  @gather)

(define (match-branch @x) (catch (_match-branch @x)))
(define (_match-branch @branch, @cache @match)
  (set '@cache $POS)
  (dolist (@atom @branch)
    (set '@match (match-rule @atom))
    (if (is-nil @match) (set '$POS @cache)
      (return @match))) nil)

(define (match-ntoken @name, @rule @match)
  (set '@rule (get-token-rule @name))
  (set '@match (match-rule @rule))
  (if (is-nil @match) nil
    (name-match @name @match)))

(define (match-ctoken @name)
  (match-rule (get-token-rule @name)))

(define (match-rtoken @name, @rule @match)
  (set '@rule (get-token-rule @name))
  (set '@match (match-rule @rule))
  (if (is-nil @match) nil true))

(define (match-gtoken @name, @rule @cache)
  (set '@rule (get-token-rule @name))
  (set '@cache $POS)
  (cond
    ((match-rule @rule) nil)
    (true (set '$POS @cache) true)))

(define (match-rept @x) (catch (_match-rept @x)))
(define (_match-rept @atoms)
  (local (@gather @match-time
      @atom @rept @min-time @max-time @cache @match)
    (set '@gather true)
    (set '@match-time 0)
    (map set '(@atom @rept) @atoms)
    (map set '(@min-time @max-time) @rept)
    (while (!= @max-time @match-time)
      (set '@cache $POS)
      (set '@match (match-rule @atom))
      (when (is-nil @match)
        (when (< @match-time @min-time) (return nil))
        (set '$POS @cache)
        (return @gather))
      (inc @match-time)
      (set '@gather (gather-match @gather @match)))
    (return @gather)))

(define (match-look @x) (catch (_match-look @x)))
(define (_match-look @atoms)
  (local (@atom @rept @look
      @gather @match-time @min-time @max-time @match @cache)
    (map set '(@atom @rept @look) @atoms)
    (set '@gather true)
    (set '@match-time 0)
    (map set '(@min-time @max-time) @rept)
    (when (>= @match-time @min-time)
      (set '@match (match-rule @look))
      (when (true? @match)
        (return (gather-match @gather @match))))
    (while (!= @match-time @max-time)
      (set '@cache $POS)
      (set '@match (match-rule @atom))
      (when (is-nil @match)
        (when (< @match-time @min-time) (return nil))
        (set '$POS @cache)
        (set '@match (match-rule @look))
        (when (is-nil @match) (return nil))
        (return (gather-match @gather @match)))
      (inc @match-time)
      (set '@gather (gather-match @gather @match))
      (when (>= @match-time @min-time)
        (set '@cache $POS)
        (set '@match (match-rule @look))
        (when (true? @match)
          (return (gather-match @gather @match)))
        (set '$POS @cache)))
    (return nil)))

(define (match-action @exprs, @atom)
  (set '@atom (eval-atom @exprs))
  ;; (say @atom) (exit)
  (cond
    ((is-str @atom) (match-str @atom))
    ((is-list @atom) (match-strs @atom))
    (true (error "Not implement match " @atom))))

(define (match-str @str) (match-regex (regex-str @str)))

(define (match-strs @strs) (exists match-str @strs))

;; ===========================================
;; capture match to data structure
;; ===========================================

(define (name-match @name @match)
  ($NS (str "$" @name) @match)
  (cond
    ((is-true @match) true)
    ((is-str @match)
      (cons @name @match))
    ((is-name-match @match)
      (cond
        ((starts-with @name {@} 0)
          (list @name (cons @match)))
        (true @match)))
    (true (list @name @match))))

(define (gather-match @gather @match)
  (cond
    ((is-true @match) @gather)
    ((is-str @match)
      (cond
        ((is-true @gather) @match)
        ((is-str @gather) (extend @gather @match))
        ((is-name-match @gather) @gather)
        (true @gather)))
    ((is-name-match @match)
      (cond
        ((is-true @gather) @match)
        ((is-str @gather) @match)
        ((is-name-match @gather) (list @gather @match))
        (true (push @match @gather -1))))
    (true
      (cond
        ((is-true @gather) @match)
        ((is-str @gather) @match)
        ((is-name-match @gather) (cons @gather @match))
        (true (append @gather @match))))))

;; ======================================
;; trace match or report error
;; ======================================

(define (match-token @rule, @type @name @cname @match)
  (map set '(@type @name) @rule)
  (set '@cname (str "<" @name ">"))
  (if ($NS @cname) (inc ($NS @cname)) ($NS @cname 0))
  (when (> ($NS @cname) 10)
    (error "call token <"@name"> in deep recursive!"))
  (case @type
    ("ntoken" (set '@match (match-ntoken @name)))
    ("rtoken" (set '@match (match-rtoken @name)))
    ("ctoken" (set '@match (match-ctoken @name)))
    (true (error "unknown token type: "@type)))
  (when (>= $POS $MAXPOS) (set '$MAXPOS $POS))
  (dec ($NS @cname))
  @match)

(define (error-report)
  (local (@table @line @to @from @error-str @tip-str)
    (when (= $MAXPOS $LEN) (error "loss close char"))
    (set '@table (flat (ref-all "\n" (explode $STR))))
    (set '@line (len (parse (0 $MAXPOS $STR) "\n")))
    (set '@to (exists (fn (x) (>= x $MAXPOS)) @table))
    (set '@from (exists (fn (x) (<= x $MAXPOS)) (reverse @table)))
    (if (is-nil @from) (set '@from 0))
    (if (is-nil @to) (set '@to $LEN))
    (set '@error-str (substr $STR @from @to))
    (set '@tip-str (get-tip-str @from $MAXPOS @to))
    (error "line: "@line"\n"@error-str"\n"@tip-str)))

;;===========================================================
;; Spp data to str for repl or debug
;;===========================================================

(define (atom-to-str @atom)
  (cond
    ((is-nil @atom)   "nil")
    ((is-true @atom)  "true")
    ((is-str @atom)   (str-to-str @atom))
    ((is-int @atom)   (str @atom))
    ((is-sym @atom)   (term @atom))
    ((is-ns @atom)    (term @atom))
    ((is-ref @atom)   (join (last @atom) "."))
    ((is-list @atom)  (list-to-str @atom))
    ((is-func @atom)  (func-to-str (last @atom)))
    ((is-rule @atom)  (rule-to-str (last @atom)))
    ((is-array @atom) (array-to-str (last @atom)))
    ((= $TO @atom)    (last @atom))
    ((= $DOT @atom)   (last @atom))
    ((lambda? @atom)  "built-in-function")
    (true (error "unknown atom to str: " @atom))))

(define (atoms-to-str @atoms)
  (join (map atom-to-str @atoms) " "))

(define (format-str @str)
  (join (map char-to-str (explode @str))))

(define (str-to-str @str) (str {"} (format-str @str) {"}))

(define (char-to-str @char)
  (case @char
    ("\n" "\\n")
    ("\t" "\\t")
    ("\r" "\\r")
    ("\"" "\\\"")
    ("\\" "\\\\")
    ("/"  "\\/")
    (true @char)))

(define (func-to-str @atom, @args-str @exprs-str)
  (set '@args-str (list-to-str (first @atom)))
  (set '@exprs-str (atoms-to-str (rest @atom)))
  (str "(func " @args-str " " @exprs-str ")"))

(define (array-to-str @atoms)
  (str "[" (join (map atom-to-str @atoms) ",") "]"))

(define (list-to-str @atoms)
  (str "(" (join (map atom-to-str @atoms) " ") ")"))

(define (rule-to-str @rule)
  (str ":" (token-to-str @rule) ":"))

;; =========================================
;; rule atom to str

(define (token-to-str @token, @type @value)
  (map set '(@type @value) @token)
  (case @type
    ("action" (action-to-str @value))
    ("branch" (branch-to-str @value))
    ("regex"  (regex-to-str @value))
    ("ctoken" (str "<:" @value ">"))
    ("group"  (group-to-str @value))
    ("gtoken" (str "<!" @value ">"))
    ("look"   (look-to-str @value))
    ("ntoken" (str "<" @value ">"))
    ("rept"   (rept-to-str @value))
    ("rtoken" (str "<." @value ">"))
    ("rules"  (rules-to-str @value))
    (true (error "unknown rule type: "@type))))

(define (action-to-str @value)
  (str "{" (join (map atom-to-str @value) " ") "}"))

(define (rules-to-str @ratoms)
  (join (map token-to-str @ratoms)))

(define (group-to-str @rules)
  (str "(" (rules-to-str @rules) ")"))

(define (branch-to-str @branches)
  (str "(" (join (map token-to-str @branches) "|") ")"))

(define (rept-to-str @rept, @token-str @rept-str)
  (set '@token-str (token-to-str (@rept 0)))
  (set '@rept-str (last (@rept 1)))
  (str @token-str @rept-str))

(define (look-to-str @look, @rept-str @look-str)
  (set '@rept-str (rept-to-str (0 2 @look)))
  (set '@look-str (token-to-str (@look 2)))
  (str @rept-str @look-str))

(define (regex-to-str @str, @match)
  (set '@str (str ":" @str ":"))
  (set '@match (match-grammar "Spp" @str))
  (cond
    ((not-nil @match) (regex-atoms-to-str (last @match)))
    (true (error "could not parse regex str: "@str))))

(define (regex-atoms-to-str @atoms)
  (join (map regex-atom-to-str @atoms)))

(define (regex-atom-to-str @atom, @type @value)
  (map set '(@type @value) @atom)
  (case @type
    ("look"     (join (map last @value)))
    ("@chclass" (chclass-to-str @value))
    ("@group"   (str "(" (regex-atoms-to-str @value) ")"))
    (true       @value)))

(define (chclass-to-str @nodes, @type @value @strs)
  (set '@strs '())
  (dolist (@node @nodes)
    (map set '(@type @value) @node)
    (case @type
      ("pname"  (push (pname-to-str @value) @strs -1))
      ("posix"  (push (posix-to-str @value) @strs -1))
      ("cclass" (push @value @strs -1))
      ("char"   (push @value @strs -1))
      ("flip"   (push @value @strs -1))
      ("cchar"  (push @value @strs -1))
      ("alpha"  (push @value @strs -1))
      (true (error "unknown chclass node: "@type))))
  (cond
    ((= 1 (len @strs)) (first @strs))
    (true (str "[" (join @strs) "]"))))

(define (pname-to-str @name)
  (case @name
    ("lower" "\\l")
    ("upper" "\\u")
    ("blank" "\\b")
    ("xdigit" "\\x")
    (true (error "unknown pname: "@name))))

(define (posix-to-str @nodes, @type @value @flag @cclass)
  (set '@flag 0)
  (dolist (@node @nodes)
    (map set '(@type @value) @node)
    (case @type
      ("flip" (set '@flag 1))
      ("pname"
        (set '@cclass (pname-to-str @value))
        (if (= @flag 1)
          (set '@cclass (upper-case @cclass))))
      (true (error "unknown posix type" @type))))
  @cclass)

;; ==============================================
;; check file if have NO ASCII char
;; ==============================================

(define (check-file @file, @text)
  (set '@file (eval-atom @file))
  (set '@text (read-file @file))
  (if (for-all (fn (x) (< (char x) 127)) (explode @text))
    (say "ok: <"@file"> all char is ASCII")
    (say "no: <"@file"> have char is not ASCII")))

;; ====================================================
;; check grammar all token define ok

(define (check-grammar @name, @rule)
  (if (is-ns (Main @name))
    (say "ok: grammar name exists.")
    (error "grammar name not exists!"))
  (in-ns @name)
  (set '@rule ($NS "Top"))
  (if (is-rule @rule)
    (say "ok: door name ok")
    (error "not exists door name"))
  ($NS (str "$" @name) true)
  (check-rule (last @rule))
  (check-un-used-token)
  (out-ns @name))

(define (check-un-used-token, @pairs @rule @name @check-name)
  (set '@pairs (symbols $NS))
  (dolist (@pair @pairs)
    (when (is-list @pair)
      (set '@rule (last @pair))
      (when (is-rule @rule)
        (set '@name (first @pair))
        (set '@check-name (str "$" @name))
        (if (is-nil ($NS @check-name))
          (say "error: not used token! <"@name">"))))))

(define (check-rule @rule, @type @value)
  (map set '(@type @value) @rule)
  (case @type
    ("rules"  (check-rules @value))
    ("group"  (check-rules @value))
    ("branch" (check-branch @value))
    ("ntoken" (check-token @value))
    ("rtoken" (check-token @value))
    ("ctoken" (check-token @value))
    ("gtoken" (check-token @value))
    ("look"   (check-look  @value))
    ("rept"   (check-rept  @value))
    ("regex"  true)
    (true (error "Unknown rule type check: "@type))))

(define (check-rules @rules)
  (map check-rule @rules))

(define (check-branch @branches)
  (map check-rule @branches))

(define (check-token @name, @rule @check-name)
  (set '@rule ($NS @name))
  (cond
    ((and (true? @rule) (is-rule @rule))
      (set '@check-name (str "$" @name))
      (when (is-nil ($NS @check-name))
        ($NS @check-name true)
        (check-rule (last @rule))))
    (true (say "not exists token name: <"@name">"))))

(define (check-rept @rules)
  (check-rule (first @rules)))

(define (check-look @rules)
  (check-rule (first @rules))
  (check-rule (last @rules)))

;; ===========================================================
;; function for main args
;; ===========================================================

(define (boot-spp)
  (cond
    ((true? $SPP-MATCH)
      (eval-atom (opt-match $SPP-MATCH)))
    (true (load-lsp-grammar $SPP-LSP))))

;; register
(define (spp-json @json-file, @match)
  (set '@match (match-grammar $LANG (read-file $SPP-RULE)))
  (cond
    ((true? @match)
      (write-file @json-file (to-json @match)))
    (true (error-report)
      (error "Could not parse rule file: " $SPP-RULE))))

;; register
(define (spp-lsp @lsp-file)
  (set '$SPP-MATCH (match-grammar $LANG (read-file $SPP-RULE)))
  (cond
    ((true? $SPP-MATCH) (save @lsp-file '$SPP-MATCH))
    (true (error-report)
      (error "Could not parse rule file: " $SPP-RULE))))

(define (load-json-grammar @json-file, @match @opt-atom)
  (set '@match (load-json @json-file))
  (if (is-nil @match) (error "load "@json-file" error!"))
  (set '@opt-atom (opt-match @match))
  (eval-atom @opt-atom))

(define (load-lsp-grammar @lsp-file)
  (load @lsp-file)
  (cond
    ((is-nil $SPP-MATCH)
      (error "load "@lsp-file" get nothing!"))
    (true (eval-atom (opt-match $SPP-MATCH)))))

(define (comp @spp-file @json-file, @text @match)
  (boot-spp)
  (set '@text (read-file @spp-file))
  (set '@match (match-grammar $LANG @text))
  (cond
    ((true? @match)
      (write-file @json-file (to-json @match)))
    (true (error-report))))

(define (repl, @str @match @opt-atom @eval-atom)
  (boot-spp)
  (say "This is Spp REPL (newlisp), 'exit' to exit.")
  (while true
    (print ">> ")
    (set '@str (trim (read-line)))
    (when (= @str "exit") (exit))
    (set '@match (match-grammar $LANG @str))
    (cond
      ((is-nil @match) (error-report))
      (true
        ;; (say "match --> " @match)
        (set '@opt-atom (opt-match @match))
        (say "opt ==> " @opt-atom)
        (set '@eval-atom (eval-atom @opt-atom))
        (say (atom-to-str @eval-atom))))))

(define (spp @spp-file, @str @opt-atom @match)
  (boot-spp)
  (when (is-file @spp-file)
    (set '@str (read-file @spp-file))
    (set '@match (match-grammar $LANG @str))
    (cond
      ((is-nil @match) (error-report))
      (true
        (set '@opt-atom (opt-match @match))
        (eval-atom @opt-atom)))))

;; ====================================================
;; eval-atom
;; ====================================================

(define (eval-atom @atom)
  (cond
    ((= '() @atom)    @atom)
    ((is-list @atom)  (eval-list @atom))
    ((is-array @atom) (eval-array (last @atom)))
    ((is-sym @atom)   (eval-sym @atom))
    ((is-ref @atom)   (eval-ref (last @atom)))
    (true @atom)))

(define (eval-sym @x) (catch (_eval-sym @x)))
(define (_eval-sym @sym, @value @name)
  (set '@name (term @sym))
  (dolist (@namespace @NS)
    (set '@value (@namespace @name))
    (if (not-nil @value) (return @value)))
  ;; (say "warn: undefined symbol: " @name)
  @sym)

(define (eval-array @array)
  (to-obj "array" (map eval-atom @array)))

(define (eval-atoms @atoms) (map eval-atom @atoms))
(define (eval-list @atoms, @args @atom)
  (set '@args (rest @atoms))
  (set '@atom (eval-atom (@atoms 0)))
  (cond
    ((lambda? @atom) (apply @atom @args))
    ((is-func @atom)
      (call-func (last @atom) (eval-atoms @args)))
    ;; (Ns "name") vs (get Ns "name")
    ;; (Ns "name" 1) vs (set Ns "name" 1)
    ;; (keys Ns) to compare if exists key
    ;; but not nil value in it
    ;; (set Ns key nil) is delete key
    ((is-ns @atom)
      (cond
        ((= 1 (len @atoms)) (@atom))
        ((= 2 (len @atoms)) (@atom (last @atoms)))
        (true (@atom (nth 1 @atoms) (nth 2 @atoms)))))
    (true (eval-atoms @atoms))))

(define (eval-to)
  (let (@return (eval-atom (first (args))))
  (dolist (@slot (rest (args)))
    (cond
      ;; @return -> (map @x) => (map @x @return)
      ((is-list @slot)
        (set '@return (eval-list (push @return @slot -1))))
      ((is-sym @slot)
        (set '@slot (eval-sym @slot))
        (cond
          ;; if is register function
          ;; "str" -> split (split "str")
          ((lambda? @slot)
            (set '@return (@slot @return)))
          ;; when is not defined symbol
          ;; then save retrun to this sym
          ((is-sym @slot)
            (set '@return (eval-my @slot @return)))
          (true (error "have not implement:" (list @slot @return)))))
        ;; if meet 1 "str" atom, then ignore @return
        ;; (1 -> 1 -> 1) => 1
        ;; also could implement other use
        (true (set '@return (eval-atom @slot)))))
  @return))

;; type is just function that return value if it is match 
;; this type, or transfer other type to this type if could
;; or throw error.
;; argument also could use type assertion
;; (func ((int x) (int y)) (return (x + y)))
;;(define (eval-type @name @func)
;; (type Int (func ..) -> is-int (pass Int return true)
;; self-hosts is use itself to write interpreter of it.
;; spp-newlisp, reflect all of Spp to newlisp code.
;; some code could reflect newlisp, but grammar to data structure
;; or some other code

(define (eval-return @atom)
  ($CALL ":return" true) (eval-atom @atom))

(define (eval-func)
  (let (@name ((args) 0) @exprs (rest (args)))
    (cond
      ((is-sym @name)
        (my-pair @name (to-obj "func" @exprs)))
      ((is-list @name) (to-obj "func" (args)))
      (true (error "(func ..) syntax error")))))

(define (eval-exprs @exprs)
  (cond
    ((ref 'return @exprs)
      (eval-return-exprs @exprs))
    (true
      (dolist (@expr @exprs)
        (eval-atom @expr)))))

(define (eval-return-exprs @x) (catch (_eval-return-exprs @x)))
(define (_eval-return-exprs @exprs, @return)
  (dolist (@expr @exprs)
    (set '@return (eval-atom @expr))
    (if ($CALL ":return") (return @return)))
  @return)

(define (call-func @def-exprs @values)
  (local (@namespace @syms @exprs @return)
    (set '@syms (first @def-exprs))
    (set '@exprs (rest @def-exprs))
    (set '@namespace (uid))
    (in-func @namespace)
    (when (> (len @syms) 0)
      (map my-pair @syms @values))
    (set '@return (eval-exprs @exprs))
    (out-func @namespace)
    @return))

(define (eval-ref @ref, @ns @package @name @value)
  (map set '(@ns @name) @ref)
  (set '@package (eval-atom @ns))
  (cond
    ((is-ns @package)
     (cond
       ((is-sym @name)
        (set '@value (@package (term @name)))
        (cond
          ((not-nil @value) @value)
          (true (error "undefine <"@value"> in ns <"@ns">"))))
       (true (error "undefine package <"@ns">"))))
    ((and (true? @package) (is-sym @name))
     (eval-list (list @name @package)))
    (true (error "have not implement"))))

;; ====================================================
;; register function
;; ====================================================

(define (eval-parse @str @atom, @rule @match @door)
  (set '@str  (eval-atom @str))
  (set '@rule (eval-atom @atom))
  (cond
    ((is-str @str)
      (cond
        ;; (str ~~ str)
        ((is-str @rule)
          (regex @rule @str 6))
        ;; (str ~~ :rule:)
        ((is-rule @rule)
          (new-match @str)
          (match-rule (last @rule)))
        ;; (str ~~ grammar)
        ((is-ns @rule)
          (in-ns (term @atom))
          (new-match @str)
          (set '@door (get-token-rule "Top"))
          (set '@match (match-rule @door))
          (out-ns (term @atom))
          @match)
        (true (error "(str ~~ rule or grammar)"))))
    (true (error @str" Could not ~~ "@rule))))

(define (eval-if) (catch (_eval-if (args))))
(define (_eval-if @args, @cond @exprs @flag)
  (set '@flag 0 '@exprs '())
  (set '@cond (eval-atom (first @args)))
  (dolist (@atom (1 @args))
    (cond
      ((= 'else @atom)
        (if (not-nil @cond)
          (return (eval-exprs @exprs))
          (set '@flag 1 '@exprs '())))
      (true (push @atom @exprs -1))))
  (cond
    ((= @flag 1) (eval-exprs @exprs))
    (true
      (if (is-nil @cond) nil
        (eval-exprs @exprs)))))

(define (eval-case) (catch (_eval-case (args))))
(define (_eval-case @args, @target)
  (set '@target (eval-atom (@args 0)))
  (dolist (@branch (rest @args))
    (when (is-list @branch)
      (cond
        ((= 'when (@branch 0))
          (if (= @target (eval-atom (@branch 1)))
            (return (eval-exprs (2 @branch)))))
        ((= 'else (@branch 0))
          (return (eval-exprs (rest @branch))))
        (true (eval-list @branch)))))
  (return nil))

(define (eval-begin) (catch (_eval-begin (args))))
(define (_eval-begin @exprs, @block @return)
  (set '@block (uid))
  (in-block @block)
  (set '@return (eval-exprs @exprs))
  (out-block @block)
  @return)

(define (eval-while) (catch (_eval-while (args))))
(define (_eval-while @args)
  (local (@guide, @exprs @block @return)
    (set '@guide (@args 0))
    (set '@exprs (rest @args))
    (while (eval-atom @guide)
      (set '@block (uid))
      (in-block @block)
      (set '@return (eval-exprs @exprs))
      (when ($CALL ":return")
        (out-block @block) (return @return))
      (out-block @block))
    (return @return)))

(define (eval-for) (catch (_eval-for (args))))
(define (_eval-for @args)
  (local (@var @values @exprs @block @return)
    (map set '(@var @values) (@args 0))
    (set '@exprs (rest @args))
    (set '@values (eval-atom @values))
    (if (is-array @values) (set '@values (last @values)))
    (if (is-list @values)
      (dolist (@value @values)
        (set '@block (uid))
        (in-block @block)
        (my-pair @var @value)
        (set '@return (eval-exprs @exprs))
        (when ($CALL ":return")
          (out-block @block) (return @return))
        (out-block @block))
      (return @return))))

(define (eval-assign @sym @value)
  (set '@value (eval-atom @value))
  (cond
    ((is-sym @sym)
      (assign-pair @sym @value))
    ((and (is-list @sym) (is-list @value))
      (map assign-pair @sym @value))
    (true (error "assign syntax error"))))

(define (assign-pair @x @y) (catch (_assign-pair @x @y)))
(define (_assign-pair @sym @value, @name)
  (set '@name (term @sym))
  (dolist (@namespace @NS)
    (when (not-nil (@namespace @name))
      (@namespace @name @value)
      (return @value)))
  (error "assign undefined sym: "@name))

(define (eval-ok @expr @expect @message)
  (local (@expr-str @expect-str
      @expr-get @expr-get-str @expect-get)
    (set '@expr-str (atom-to-str @expr 1))
    (set '@expect-str (atom-to-str @expect 1))
    (set '@expr-get (eval-atom @expr))
    (set '@expr-get-str (atom-to-str @expr-get 1))
    (set '@expect-get (eval-atom @expect))
    (if (is-nil @message) (set '@message ""))
    (++ $TC)
    (if (= @expr-get @expect-get)
      (say "ok "$TC" - "@expr-str" == "@expect-str" "@message)
      (say "not "$TC" - "@expr-str" == "@expect-str" "@message)
      (say "get: "@expr-get-str" expect: "@expect-str))))

(define (eval-my @syms @values)
  (cond
    ((is-nil @values)
      (cond
        ((is-sym @syms) (my-pair @syms true))
        ((is-list @syms)
          (set '@values (dup true (len @syms)))
          (map my-pair @syms @values))
        (true (error "(my x) type error" @syms))))
    (true
      (set '@values (eval-atom @values))
      (cond
        ((is-sym @syms) (my-pair @syms @values))
        ((and (is-list @syms) (is-list @values))
          (map my-pair @syms @values))
        (true (error "(my x y) syntax error" @syms))))))

(define (my-pair @sym @value, @name)
  (set '@name (term @sym))
  (cond
    ((is-nil ($NS @name)) ($NS @name @value) @value)
    (true (error "defined my symbol: "@name))))

(define (eval-end @sym, @name)
  (cond
    ((is-sym @sym)
      (set '@name (term @sym))
      (cond
        ((= $NS (Main @name)) (out-ns @name))
        (true (error @name "> is not current context: " $NS))))
    (true (error "(end symbol) is not symbol"))))

(define (eval-grammar @sym, @name @grammar)
  (cond
    ((is-sym @sym)
      (set '@name (term @sym))
      (set '@grammar (Main @name))
      (cond
        ((is-ns @grammar) (in-context @grammar))
        ((is-nil @grammar)
          (set '@grammar (new Tree (sym @name)))
          (Main @name @grammar)
          (in-context @grammar))
        (true (error "symbol <" @sym "> have been used!"))))
    (true (error "(grammar sym) accept symbol: " @sym))))

(define (eval-say)
  (let (@atoms (eval-atoms (args)))
    (say (join (map _eval-say @atoms))) true))

(define (_eval-say @atom)
  (cond
    ((is-str @atom) @atom)
    (true (atom-to-str @atom))))

(define (eval-undef @sym, @namespace @name)
  (cond
    ((is-sym @sym)
      (set '@name (term @sym))
      (set '@namespace ($NS @name))
      (cond
        ;; is namespace
        ((is-ns @namespace)
          (if (find @namespace @NS)
            (error "Could not undef grammar in use"))
          (delete-context @sym)
          (Main @name nil) true)
        (true
          (dolist (@namespace @NS)
            (when (not-nil (@namespace @name))
              (@namespace @name nil))))))
    (true (error "undef a not symbol: " @sym))))

(define (eval-in @element @list)
  (set '@element (eval-atom @element))
  (set '@list (eval-atom @list))
  (cond
    ((is-list @list)
      (if (find @element @list) true nil))
    ((is-array @list)
      (if (find @element (last @list)) true nil))
    (true (error "($element in @list/@array)")))) 

(define (eval-range @from @to)
  (set '@from (eval-atom @from))
  (cond
    ((is-int @from)
      (cond
        ((is-nil @to) (range 1 @from))
        (true
          (set '@to (eval-atom @to))
          (cond
            ((is-int @to) (range @from @to))
            (true (error "(range ..) accept int! "@to))))))
    (true (error ("(range ..) accept int! "@from)))))

(define (eval-not @atom) (not (eval-atom @atom)))

(define (eval-exit) (exit))

(define (eval-flat @list)
  (set '@list (eval-atom @list))
  (cond
    ((is-list @list) (flat @list))
    (true (error "(flat @list)"))))

;;ok
(define (eval-add) (apply '+ (check-ints (args))))

(define (check-ints @args)
  (set '@args (eval-atoms @args))
    (cond
    ((for-all is-int @args) @args)
    (true (error "have not int element"))))

(define (eval-sub) (apply '-  (check-ints (args))))
(define (eval-lt)  (apply '<  (check-ints (args))))
(define (eval-le)  (apply '<= (check-ints (args))))
(define (eval-gt)  (apply '>  (check-ints (args))))
(define (eval-ge)  (apply '>= (check-ints (args))))
(define (eval-ne)  (apply '!= (check-ints (args))))
(define (eval-eq)  (apply '=  (eval-atoms (args))))

(define (eval-load-json @file) (load-json (eval-atom @file)))
(define (eval-is-nil @x) (is-nil (eval-atom @x)))
(define (eval-is-true @x) (is-true (eval-atom @x)))
(define (eval-not-nil @x) (not-nil (eval-atom @x)))
(define (eval-is-ns @x) (is-ns (eval-atom @x)))
(define (eval-is-func @x) (is-func (eval-atom @x)))
(define (eval-is-sym @x) (is-sym (eval-atom @x)))
(define (eval-is-rule @x) (is-rule (eval-atom @x)))
(define (eval-is-int @x) (is-int (eval-atom @x)))
(define (eval-is-array @x) (is-array (eval-atom @x)))
(define (eval-is-list @x) (is-list (eval-atom @x)))
(define (eval-is-str @x) (is-str (eval-atom @x)))
(define (eval-is-file @file) (is-file (eval-atom @file)))
(define (eval-char @x) (char (eval-atom @x)))
(define (eval-format) (apply format (eval-atoms (args))))
(define (eval-check-file @x) (check-file (eval-atom @x)))
(define (eval-check-grammar @x) (check-grammar (eval-atom @x)))

(define (eval-chop @x)
  (set '@x (eval-atom @x))
  (cond
    ((or (is-str @x) (is-list @x)) (chop @x))
    ((is-array @x) (setf (@x 1) (chop $it)) @x)
    (true (error "chop only accept str/list/array!"))))

(define (eval-rest @atom)
  (set '@atom (eval-atom @atom))
  (cond
    ((or (is-str @atom) (is-list @atom))
      (rest @atom))
    ((is-array @atom)
     (setf (last @atom) (rest $it)) @atom)
    (true (error "(rest str/list/array)"))))

(define (eval-last @atom)
  (set '@atom (eval-atom @atom))
  (cond
    ((or (is-str @atom) (is-list @atom)) (last @atom))
    ((is-array @atom) (last (last @atom)))
    (true (error "(last str/list/array)"))))

(define (eval-time @expr @times)
  (if (is-list @expr)
    (time (eval-list @expr) @times)))

(define (eval-int @str) (int (eval-atom @str)))

(define (eval-len @atom)
  (set '@atom (eval-atom @atom))
  (cond
    ((or (is-str @atom) (is-list @atom)) (len @atom))
    ((is-array @atom) (len (last @atom)))
    (true (error "(len str/list/array)"))))

(define (eval-nth @index @atom)
  (set '@index (eval-atom @index))
  (set '@atom (eval-atom @atom))
  (cond
    ((or (is-str @atom) (is-list @atom))
      (nth @index @atom))
    ((is-array @atom) (nth @index (last @atom)))
    (true (error "(nth index str/list/array)"))))

(define (eval-slice @atom @from @len)
  (set '@atom (eval-atom @atom))
  (set '@from (eval-atom @from))
  (set '@len  (eval-atom @len))
  (cond
    ((or (is-str @atom) (is-list @atom))
      (cond
        ((is-int @from)
          (cond
            ((is-nil @len) (slice @atom @from))
            ((is-int @len) (slice @atom @from @len))
            (true (error "(slice * * nil/@int)"))))
        (true (error "(slice * @int *)"))))
    ((is-array @atom)
      (cond
        ((is-int @from)
          (cond
            ((is-nil @len)
              (to-obj "array" (slice (last @atom) @from)))
            ((is-int @len)
              (to-obj "array" (slice (last @atom) @from @len)))
            (true (error "(slice * * nil/@int)"))))
        (true (error "(slice * @int *)"))))
    (true (error "(slice @str/@list/@array ..)"))))

(define (eval-trim @str)
  (set '@str (eval-atom @str))
  (cond
    ((is-str @str) (trim @str))
    (true (error "(trim @str)"))))

(define (eval-starts-with @str @starts-str)
  (set '@str (eval-atom @str))
  (set '@starts-str (eval-atom @starts-str))
  (cond
    ((is-str @str)
      (cond
        ((is-str @starts-str)
          (starts-with @str @starts-str 6))
        (true (error "(starts-with @str @str)"))))
    (true (error "(starts-with @str @str)"))))

(define (eval-repeat @element @times)
  (set '@element (eval-atom @element))
  (set '@times (eval-atom @times))
  (cond
    ((is-int @times) (dup @element @times))
    (true (error "(repeat @element int)"))))

(define (eval-first @atom)
  (set '@atom (eval-atom @atom))
  (cond
    ((or (is-str @atom) (is-list @atom))
      (first @atom))
    ((is-array @atom) (first (last @atom)))
    (true (error "(first str/list/array)")))) 

(define (eval-and)
  (for-all (fn (x) (not-nil (eval-atom x))) (args)))

(define (eval-or)
  (not-nil (exists (fn (x) (not-nil (eval-atom x))) (args))))

(define (eval-read-line) (read-line))

(define (eval-read-file @file)
  (cond
    ((is-file @file) (read-file @file))
    (true (error @file" not exists!"))))

(define (eval-write-file @file @str)
  (cond
    ((is-str @str) (write-file @file @str))
    (true (error "could not write "@str" to file"))))

(define (eval-split @str @sep)
  (set '@str (eval-atom @str))
  (set '@sep (eval-atom @sep))
  (cond
    ((is-str @str)
      (cond
        ((is-str @sep) (parse @str @sep))
        ((is-nil @sep) (explode @str))
        (true (error "@sep shouls is str/nil"))))
    (true (error "split accept str"))))

(define (eval-join @list @sep)
  (set '@list (eval-atom @list))
  (cond
    ((is-nil @sep) (join @list ""))
    ((is-str @sep) (join @list @sep))
    (true (error "join sep accept str"))))

(define (eval-pop @sym, @list)
  (set '@list (eval-atom @sym))
  (cond
    ((is-list @list)
     (set '@list (rest @list)))
    ((is-array @list)
     (setf (last @list) (rest $it)))
    (true (error "(pop list/array)")))
  (cond
    ((is-sym @sym)
      (assign-pair @sym @list) @list)
    (true @list)))

(define (eval-shift @sym, @list)
  (set '@list (eval-atom @sym))
  (cond
    ((is-list @list)
      (set '@list (chop @list)))
    ((is-array @list)
      (setf (last @list) (chop $it)))
    (true (error "(shift @list)" @list)))
  (cond
    ((is-sym @sym) (assign-pair @sym @list) @list)
    (true @list)))

(define (eval-inc @sym @num, @value)
  (set '@value (eval-atom @sym))
  (cond
    ((is-int @value)
      (cond
        ((is-nil @num) (++ @value))
        ((is-int @num) (++ @value @num))
        (true (error "(inc "@value")"))))
    (true (error "inc only could add int: "@value)))
  (if (is-sym @sym) (assign-pair @sym @value))
  @value)

(define (eval-dec @sym @num, @value)
  (set '@value (eval-atom @sym))
  (cond
    ((is-int @value)
      (cond
        ((is-nil @num) (-- @value))
        ((is-int @num) (-- @value @num))
        (true (error "(dec "@value")"))))
    (true (error "dec only could - int: "@value)))
  (if (is-sym @sym) (assign-pair @sym @value))
  @value)

;; (@list << $tail)
(define (eval-push @sym @tail, @list)
  (set '@list (eval-atom @sym))
  (set '@tail (eval-atom @tail))
  (cond
    ((is-list @list)
      (push @tail @list -1))
    ((is-array @list)
      (push @tail (last @list) -1))
    (true
      (error "(@list << $tail) target isn't list")))
  (if (is-sym @sym) (assign-pair @sym @list))
  @list)

;; (@head >> @list)
(define (eval-unshift @head @sym, @list)
  (set '@list (eval-atom @sym))
  (set '@head (eval-atom @head))
  (cond
    ((is-list @list) (push @head @list))
    ((is-array @list) (push @head (last @list)))
    (true
      (error "(@list << $element) isn't list/array")))
  (if (is-sym @sym) (assign-pair @sym @list))
  @list)

(define (eval-array-list @array)
  (set '@array (eval-atom @array))
  (cond
    ((is-array @array)
      (last @array))
    (true (error "(array-list @array)"))))

(define (eval-list-array @list)
  (set '@list (eval-atom @list))
  (cond
    ((is-list @list)
      (to-obj "array" @list))
    (true (error "(list-array @list)"))))

(define (eval-ns) $NS)
(define (eval-call) $CALL)
(define (eval-block) $BLOCK)
(define (rand-str) (0 8 (uuid)))
(define (eval-new @type)
  (cond
    ((is-sym @type)
     (case @type
       (hash (new Tree (sym (string "Hash-" (rand-str)))))
       (ns   (new Tree (sym (string "Ns-" (rand-str)))))
       (true (error "not implement (new "@type")"))))
    (true (error "(new hash/ns)"))))

;; ============================================
;; symbol reflection table
;; ============================================

(Main "!="            eval-ne) ;; ok
(Main "+"             eval-add) ;; ok
(Main "-"             eval-sub) ;; ok
(Main "<"             eval-lt) ;; ok
(Main "<<"            eval-push) ;; ok
(Main "<="            eval-le) ;; ok
(Main "="             eval-assign) ;; ok
(Main "=="            eval-eq) ;; ok
(Main ">"             eval-gt) ;; ok
(Main ">="            eval-ge) ;; ok
(Main ">>"            eval-unshift) ;; ok
(Main "and"           eval-and) ;; ok
(Main "begin"         eval-begin) ;; ok
(Main "case"          eval-case) ;; ok
(Main "char"          eval-char) ;; ok
(Main "check-file"    eval-check-file) ;; ok
(Main "check-grammar" eval-check-grammar) ;; ok
(Main "chop"          eval-chop) ;; ok
(Main "dec"           eval-dec) ;; ok
(Main "func"          eval-func) ;; ok
(Main "end"           eval-end) ;; ok
(Main "error-report"  error-report) ;; ok
(Main "eval"          eval-atom) ;;ok
(Main "exit"          eval-exit) ;; ok
(Main "exprs"         eval-exprs) ;; ok
(Main "first"         eval-first) ;; ok
(Main "flat"          eval-flat) ;; ok
(Main "for"           eval-for) ;; ok
(Main "format"        eval-format) ;; ok
(Main "grammar"       eval-grammar) ;; ok
(Main "if"            eval-if) ;; ok
(Main "in"            eval-in) ;; ok
(Main "inc"           eval-inc) ;; ok
(Main "int"           eval-int) ;; ok
(Main "is-func"       eval-is-func) ;; ok
(Main "is-file"       eval-is-file) ;; ok
(Main "is-int"        eval-is-int) ;; ok
(Main "is-list"       eval-is-list) ;; ok
(Main "is-array"      eval-is-array) ;; ok
(Main "is-nil"        eval-is-nil) ;; ok
(Main "is-ns"         eval-is-ns) ;; ok
(Main "is-sym"        eval-is-sym) ;; ok
(Main "is-true"       eval-is-true) ;; ok
(Main "is-str"        eval-is-str) ;; ok
(Main "is-rule"       eval-is-rule) ;; ok
(Main "join"          eval-join) ;; ok
(Main "last"          eval-last) ;; ok
(Main "len"           eval-len) ;; ok
(Main "load-json"     eval-load-json) ;; ok
(Main "my"            eval-my) ;; ok
(Main "not"           eval-not) ;; ok
(Main "not-nil"       eval-not-nil) ;; ok
(Main "ns"            eval-ns) ;; ok
(Main "call"          eval-call) ;; ok
(Main "block"         eval-block) ;; ok
(Main "nth"           eval-nth) ;; ok
(Main "ok"            eval-ok) ;; ok
(Main "or"            eval-or) ;; ok
(Main "parse"         eval-parse) ;; ok
(Main "pop"           eval-pop) ;; ok
(Main "push"          eval-push) ;; ok
(Main "range"         eval-range) ;; ok
(Main "read-file"     eval-read-file) ;; ok
(Main "read-line"     eval-read-line) ;; ok
(Main "repeat"        eval-repeat) ;; ok
(Main "rest"          eval-rest) ;; ok
(Main "return"        eval-return) ;; ok
(Main "say"           eval-say) ;; ok
(Main "set"           eval-assign) ;; ok
(Main "shift"         eval-shift) ;; ok
(Main "slice"         eval-slice) ;; ok
(Main "split"         eval-split) ;; ok
(Main "spp-json"      spp-json) ;; ok
(Main "spp-lsp"       spp-lsp) ;; ok
(Main "starts-with"   eval-starts-with) ;; ok
(Main "time"          eval-time) ;; ok
(Main "to"            eval-to) ;; ok
(Main "to-json"       to-json) ;; ok
(Main "trace-match"   trace-match) ;; ok
(Main "trim"          eval-trim) ;; ok
(Main "undef"         eval-undef) ;; ok
(Main "unshift"       eval-unshift) ;; ok
(Main "while"         eval-while) ;; ok
(Main "write-file"    eval-write-file) ;; ok
(Main "~~"            eval-parse) ;; ok
(Main "array-list"    eval-array-list) ;; ok
(Main "list-array"    eval-list-array) ;; ok
(Main "new"           eval-new) ;; ok
(Main "uuid"          rand-str) ;; ok
(Main "error"         error) ;; ok

;; =================================================
;; use call Spp interface
;; =================================================

(define (process-main-args, @args @len)
  (set '@args (main-args))
  (if (= "newlisp" (first @args))
    (set '@args (rest @args)))
  (set '@len (len @args))
  (cond
    ((= @len 1) (repl))
    ((= @len 2) (spp (last @args)))
    ((= @len 3)
      (cond
        ((ref "-c" @args) (load-grammar (last @args)))
        (true (apply comp (rest @args)))))
    (true
      (say "repl: > spp")
      (say "run:  > spp target.lsp")
      ;; optimizer format
      (say "comp: > spp target.lsp target.json")
      (say "boot: > spp -c target.json"))))

(process-main-args)

(exit)
